The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/tpb4_src.zip/TYPEFILE.PAS

Pascal/Delphi Source File | 1988-09-13 | 10KB | 361 lines

{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
  Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault

  Last modified  ::  7-12-88 4:42 pm
}

{$R-}                             {Range checking off}
{$B-}                             {Boolean complete evaluation off}
{$S-}                             {Stack checking off}
{$I+}                             {I/O checking on}
{$N-}                             {No numeric coprocessor}

Unit TypeFile;

Interface

Uses
  TPCrt, Globals, TPDOS,
  Core1, Core2, Dirs, DeArc;


procedure SendText;


  {==========================================================================}


Implementation



  procedure SendText;

  const
    bufsize         = 128;
    bufblocks       = 128;

  var
    This            : FilePtr;
    Xfrname         : DosFileName;
    XfrFile         : untype_file;
    Buffer          : array[1..bufsize] of Byte;
    ErrMsg          : StrStd;
    FileType        : Str3;


    function check_extension : Boolean;

    var
      FileType        : string[3];
      i               : Integer;

    begin
      i := Pos('.', Xfrname);
      if 0 = i then
        FileType := ''
      else
        FileType := Copy(Xfrname, Succ(i), Length(Xfrname));
      if (FileType = 'COM') or (FileType = 'OBJ') or (FileType[2] = 'Z')
      or (FileType = 'EXE') or (FileType = 'LBR') or (FileType = 'ARC') then
        begin
          check_extension := False;
          WriteLn(Com, 'Sorry, you can''t type ', FileType, ' files.');
        end
      else
        check_extension := True;
    end;


    procedure SendFile(var XfrFile     : untype_file;
                       remaining       : LongInt);
      { Send a squeezed or ASCII file }

    const
      recognize       = $FF76;
      DLE             = $90;

    var
      EndOfFile,
      squeezed,
      connected       : Boolean;
      i, x,
      BufferPtr,
      bpos, curin,
      repct,
      lastc,
      line_count,
      NoOfRecs,
      result          : Integer;
      dnode           : array[0..255, 0..1] of Integer;


      function getc   : Integer;
        { Get an 8 bit value from the input buffer - read block if necessary }

      begin
        if BufferPtr > bufsize then
          begin
            NoOfRecs := min(bufblocks, remaining);
            if NoOfRecs < bufblocks then
              Buffer[Succ(NoOfRecs)] := 26;
            EndOfFile := (NoOfRecs = 0);
            if not EndOfFile then
              BlockRead(XfrFile, Buffer, NoOfRecs, result);
            remaining := remaining-result;
            BufferPtr := 1
          end;
        getc := Buffer[BufferPtr];
        Inc(BufferPtr)
      end;


      function getw   : Word;
        { Get a 16 bit value from the input buffer }

      var
        temp            : Byte;

      begin
        temp := getc;
        getw := temp+Swap(getc)
      end;


      procedure BuildTree;
        { Build decode tree }

      var
        i               : Integer;
        CheckSum,
        numnodes        : Word;

      begin
        ErrMsg := '';
        if recognize = getw       { Is it really a squeezed file? }
        then
          begin
            CheckSum := getw;     { Get checksum }
            Xfrname := '';
            i := getc;            { Build original file name }
            while i <> 0 do
              begin
                Xfrname := Xfrname+Upcase(Chr(i));
                i := getc
              end;
            numnodes := getw;     { Get the number of nodes in tree }
            if (0 < numnodes) and (numnodes <= 256) then
              for i := 0 to Pred(numnodes) do
                begin
                  dnode[i, 0] := Integer(getw);
                  dnode[i, 1] := Integer(getw);
                end
            else
              begin
                ErrMsg := 'Invalid decode tree size.';
                squeezed := False
              end
          end
        else
          squeezed := False
      end;


      function gethuff : Integer;
        { Get character coding }

      var
        i               : Integer;

      begin
        i := 0;
        repeat
          Inc(bpos);
          if bpos > 7 then
            begin
              curin := getc;
              bpos := 0
            end
          else
            curin := curin shr 1;
          i := dnode[i, curin and $0001]
        until i < 0;
        i := -Succ(i);
        if i = 0 then
          gethuff := 26
        else
          gethuff := i
      end;


      function getcr  : Integer;

      var
        C               : Integer;

      begin
        if repct > 0 then
          begin
            repct := Pred(repct);
            getcr := lastc
          end
        else
          begin
            C := gethuff;
            if C = DLE then
              begin
                repct := gethuff;
                if repct = 0 then
                  getcr := DLE
                else
                  begin
                    repct := repct-2;
                    getcr := lastc
                  end
              end
            else
              begin
                getcr := C;
                lastc := C
              end
          end
      end;

    begin                         { SendFile }
      connected := Online;
      if (not connected) then
        SetSect(SetName)
      else
        begin
          i := Pos('.', Xfrname);
          if i = 0 then
            FileType := ''
          else
            FileType := Copy(Xfrname, Succ(i), Length(Xfrname));
          squeezed := ('Q' = FileType[2]);
          repct := 0;
          bpos := 8;
          ErrMsg := '';
          BufferPtr := MaxInt;    { Force a read the first time }
          EndOfFile := False;
          if remaining > 0 then
            begin
              if squeezed then
                BuildTree;
              if check_extension then
                begin
                  line_count := 0;
                  if squeezed then
                    begin
                      WriteLn(Com, '      ---> ', Xfrname);
                      x := getcr
                    end
                  else
                    x := getc;
                  while (not brk) and (not EndOfFile) and (x <> 26) and
                  ((line_count < line_abort) or (line_abort = 0) or
                    (user_rec.access = 255)) do
                    begin
                      if x = Integer(TAB) then
                        for i := 1 to (8-(WhereX mod 8)) do
                          Write(Com, ' ')
                      else
                        Write(Com, Chr(x));
                      if (user_rec.lines <> 99) and (Chr(x) = LF) then
                        begin
                          Inc(line_count);
                          if line_count mod user_rec.lines = 0 then
                            pause
                        end;
                      if squeezed then
                        x := getcr
                      else
                        x := getc
                    end;
                  if ((line_count >= line_abort) and (line_abort <> 0) and
                    (user_rec.access < 255)) then
                    begin
                      WriteLn(Com);
                      WriteLn(Com, 'Sorry, you can only ''Type'' ',
                        line_abort, ' lines.');
                    end;
                end
            end
          else
            ErrMsg := 'Missing or empty input file.';
          if ErrMsg <> '' then
            WriteLn(Com, ErrMsg)
        end;
    end;


  begin                           { SendText }
    abort := False;
    Xfrname := correct_fn(prompt('File name', 12, 'ES'));
    if in_arc then
      begin
        This := ArcBase;
        while (This <> nil) and (Xfrname <> compress_fn(This^.fname)) do
          This := This^.next;
        if This <> nil then
          begin
            SetSect(SetName);
            if check_extension then
              TypeArc(ArcReq, Xfrname);
            SetSect(HomName);
          end
        else
          begin
            WriteLn(Com, Xfrname, ' not found.');
            Xfrname := ''
          end;
      end;
    if (Xfrname <> '') and (not in_arc) then
      begin
        if in_library then
          This := LibBase
        else
          This := DirBase;
        while (This <> nil) and (Xfrname <> compress_fn(This^.fname)) do
          This := This^.next;
        if This <> nil then
          begin
            SetSect(HomName);
            log(6, Xfrname);
            SetSect(SetName);
            if in_library then
              begin
                {$I-}
                Assign(libr_file, LibReq);
                Reset(libr_file, 1);
                Seek(libr_file, This^.index*128) {$I+} ;
                if IoResult = 0 then
                  SendFile(libr_file, This^.fsize*128);
                Close(libr_file)
              end
            else
              begin
                Assign(XfrFile, Xfrname);
                Reset(XfrFile, 1);
                SendFile(XfrFile, FileSize(XfrFile));
                Close(XfrFile);
                if in_arc then
                  begin
                    Erase(XfrFile);
                    SetSect(HomName);
                    ReadDir(DirEntries, DirSpace, DirBase);
                    new_dir := False
                  end;
              end;
            SetSect(HomName);
            log(7, '')
          end
        else
          WriteLn(Com, Xfrname, ' not found.')
      end;
  end;


end.                              { of TYPEFILE.PAS}